home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / GRAPTIES / SD204.LZH / MENUBOX.PAS < prev    next >
Pascal/Delphi Source File  |  1980-01-01  |  5KB  |  161 lines
  1. UNIT MENUBOX;
  2.  
  3. INTERFACE
  4. USES IOSTUFF,KEY2,CRT,DOS;
  5.   PROCEDURE ResetBox;
  6.   PROCEDURE SetMenuBox(X,Y: Integer; Header: AnyStr; MenuStr: LongStr);
  7.   FUNCTION PickMenuBox : Char;
  8.  
  9. IMPLEMENTATION
  10.  
  11. CONST
  12.   ColorF1   = Yellow;      { Menu Phrase colors }
  13.   ColorB1   = Blue;
  14.   ColorF2   = LightCyan;   { Foreground Color - First Letter }
  15.   ColorB2   = Blue;
  16.   ColorF3   = Black;       { Reverse Video colors for bar cursor }
  17.   ColorB3   = LightGray;
  18.   ColorF4   = LightGray;     { Border Colors }
  19.   ColorB4   = Black;
  20.   MaxMenuItems = 12;
  21.  
  22. VAR
  23.   XPos,YPos : Integer;
  24.   MenuMsg   : Array[1..MaxMenuItems] of ShortStr; { Make this longer if needed }
  25.   MenuLtr   : Array[1..MaxMenuItems] of Char;
  26.   NumPicks  : Integer;
  27.   Pick      : Integer;
  28.   LastPick  : Integer;
  29.   Longest   : Integer;
  30.   HeaderText : AnyStr;
  31.   SaveAttr  : Byte;
  32. {============================================================================}
  33. PROCEDURE ResetBox;
  34.  
  35. { Writes the box menu on the screen }
  36.  
  37. VAR
  38.     P : Integer;
  39. BEGIN
  40.     SaveAttr := TextAttr;
  41.     SetColor(ColorF4,ColorB4);
  42.     SBorder(XPos,YPos,XPos+Longest+3,YPos+NumPicks+1,HeaderText);
  43.     For P := 1 to NumPicks do Begin
  44.       FillChar(MenuMsg[P,Length(MenuMsg[P])+1],Longest-Length(MenuMsg[P]),' ');
  45.       MenuMsg[P,0] := Chr(Longest);
  46.       SetColor(ColorF1,ColorB1);
  47.       WriteSt(' '+MenuMsg[P]+' ',XPos+1,YPos+P);
  48.       SetColor(ColorF2,ColorB2);
  49.       WriteCh(MenuLtr[P],XPos+2,YPos+P);
  50.     End;
  51.     TextAttr := SaveAttr;
  52. END;
  53. {============================================================================}
  54.   PROCEDURE SetMenuBox(X,Y: Integer; Header: AnyStr; MenuStr: LongStr);
  55.  
  56.   VAR
  57.     CPos   : Integer;
  58.     Len    : Integer;
  59.  
  60.   BEGIN
  61.     XPos := X; YPos := Y;
  62.     Pick := 1;
  63.     LastPick := 1;
  64.     CPos := 1;
  65.     NumPicks := 0;
  66.     Longest := 1;
  67.  
  68.     Repeat
  69.       If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
  70.       Len := Pos('@',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
  71.       MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
  72.       MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
  73.  
  74.  
  75.       If Length(MenuMsg[NumPicks]) > Longest
  76.         then Longest := Length(MenuMsg[NumPicks]);
  77.       CPos := CPos+Len+1;
  78.     Until CPos >= Length(MenuStr);
  79.     HeaderText := Header;
  80.     If Length(HeaderText) > Longest then HeaderText[0] := chr(Longest);
  81.     ResetBox;
  82.   END;
  83.  
  84. {============================================================================}
  85.   FUNCTION PickMenuBox : Char;
  86.  
  87. CONST
  88.      UpArrow   = #72;
  89.      Downarrow = #80;
  90.      EnterKey  = #13;
  91.      EscKey    = #27;
  92.      Abort     = #0;
  93. VAR
  94.   Err,II    : Integer;
  95.   Ch        : Char;
  96.   PickExit  : Boolean;
  97.   BeepOn    : Boolean;
  98. {  FunctKey  : Boolean;     }
  99.  
  100. BEGIN
  101.  SaveAttr := TextAttr;       { Save the current colors }
  102.  HideCursor;                 { Hide the cursor }
  103.  PickExit := False;
  104.  SetColor(ColorF3,ColorB3);
  105.  
  106.                              { Write the first pick in reverse }
  107.   WriteSt(' '+MenuMsg[Pick]+' ',XPos+1,YPos+Pick);
  108.  
  109.   Repeat     { Main keystroke reading loop -- continue until enter or escape }
  110.  
  111.      Ch := Nextkey;     { Read a key }
  112.  
  113.  
  114.   If not FunctKey then Case Ch of     { Handle non function keys here }
  115.     #32..#125: Begin                  { Check characters against 1st letters }
  116.                 BeepOn := True;
  117.                  For II := 1 to NumPicks do Begin
  118.                    If UpCase(Ch) = MenuLtr[II] then Begin   { got a match }
  119.                       Pick := II;
  120.                       PickExit := True;
  121.                       BeepOn := False;
  122.                    End;
  123.                  End;
  124.                 If BeepOn then Beep;
  125.                End;
  126.     EnterKey,EscKey : PickExit := True;  { Get ready to exit }
  127.  
  128.    End; {case not functkey}
  129.  
  130.   If FunctKey then  Case Ch of     { Handle function keys here }
  131.        UpArrow   : Pick := Pred(Pick);  { Move up one }
  132.        DownArrow : Pick := Succ(Pick);  { Move down one }
  133.        Else Beep;
  134.  
  135.      End; {case functkey}
  136.  
  137.  
  138.    If Pick > NumPicks then Pick := 1;    { Make sure Pick in bounds }
  139.    If Pick < 1 then Pick := NumPicks;
  140.  
  141.    If Pick <> LastPick then Begin
  142.      SetColor(ColorF1,ColorB1);            { Restore last pick }
  143.      WriteSt(' '+MenuMsg[LastPick]+' ',XPos+1,YPos+LastPick);
  144.      SetColor(ColorF2,ColorB2);            { Restore 1st letter last pick }
  145.      WriteCh(MenuLtr[LastPick],XPos+2,YPos+LastPick);
  146.  
  147.      SetColor(ColorF3,ColorB3);            { Highlight new pick in reverse }
  148.      WriteSt(' '+MenuMsg[Pick]+' ',XPos+1,YPos+Pick);
  149.  
  150.      LastPick := Pick;
  151.    End;
  152.  
  153.  Until PickExit;
  154.  
  155.  If Ch = EscKey then PickMenuBox := Abort    { set function to #0 }
  156.                 else PickMenuBox := MenuLtr[Pick];  {set function to letter }
  157.  TextAttr := SaveAttr;   { Restore colors }
  158. End;
  159.  
  160. END. {of unit}
  161.